home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / program / 18 / forthsup / block.fth < prev    next >
Encoding:
Text File  |  1986-09-18  |  3.1 KB  |  104 lines
  1. \ This file implements standard Forth BLOCKs
  2.  
  3. decimal
  4.  
  5. \ Some f83 words I don't otherwise have
  6.   : d= ( n1a n1b n2a n2b -- f ) rot = -rot = and ;
  7.  
  8. \ Interfaces to the system-dependent code that does the actual I/O
  9.  
  10. defer read-block    (s buffer-header -- )
  11. defer write-block   (s buffer-header -- )
  12.  
  13.  1024 constant b/buf
  14.  
  15. \ The order of >block# and >file# must be preserved, and they
  16. \ must be at the start of the structure.  The program accesses
  17. \ them both at once with    <header-address> 2@
  18.  
  19. : struct 0 ;
  20. : field  \ name  ( offset size -- offset' )
  21.    create over , +
  22.    does>  @ +
  23. ;
  24.  
  25. struct ( buffer )
  26.   /n field >block#
  27.   /n field >file#
  28.   /n field >bufadd
  29.   /n field >bufflags
  30. constant /bufhdr
  31. : /bufhdr* /bufhdr * ;
  32.  
  33. \ Allocation of data structures
  34.  
  35.     4 constant #buffers
  36.  
  37. create >buffers  #buffers 1+ /bufhdr*  allot
  38. create first   b/buf #buffers *   allot
  39. here constant limit
  40.  
  41. : buffer#    (s n -- adr )   /bufhdr* >buffers +   ;
  42. : >update    (s -- adr )   1 buffer# >bufflags  ;
  43.  
  44. : update   (s -- )   >update on   ;
  45. : discard  (s -- )   1 >update ! ;
  46. : ?write-block ( buf-header -- buf-header )
  47.   dup >bufflags @ 0<
  48.   if   dup >bufadd @ over 2@ write-block  dup >bufflags off    then
  49. ;
  50. : missing   (s -- )
  51.    #buffers buffer# ?write-block ( buffer-header )
  52.    >bufadd @  >buffers >bufadd ! ( buffer )  1 >buffers >bufflags !
  53.    >buffers dup /bufhdr + #buffers /bufhdr* cmove>   ;
  54. : latest?   (s n fcb -- fcb n | a f )
  55.    swap ( offset @ + ) 2dup   1 buffer# 2@   d=
  56.    if   2drop   1 buffer# >bufadd @   false   r> drop  then  ;
  57. : absent?   (s n fcb -- a f )
  58.    latest?  false #buffers 1+ 2
  59.    do  drop 2dup i buffer# 2@ d=
  60.      if  2drop i leave  else  false  then
  61.    loop  ?dup
  62.    if  buffer# dup >buffers /bufhdr cmove   >r  >buffers dup /bufhdr +
  63.      over r> swap  -  cmove>     1 buffer# >bufadd @ false
  64.    else  >buffers 2! true  then  ;
  65. : (buffer)   (s n fcb -- a )   pause  absent?
  66.    if  missing  1 buffer#   >bufadd @  then  ;
  67. : (block)    (s n fcb -- a )
  68.    (buffer)  >update @ 0>
  69.    if   1 buffer#  dup >bufflags on       \ set flags to "block invalid"
  70.         dup >bufadd @ over 2@ read-block
  71.         >bufflags off                     \ set flags to "block clean"
  72.    then  ;
  73.  
  74. : empty-buffers   (s -- )
  75.    first limit over - erase
  76.    >buffers #buffers 1+ /bufhdr* erase
  77.    first 1 buffer#   #buffers 0
  78.    do   dup on  >bufadd  2dup !   swap b/buf + swap  >bufadd
  79.    loop   2drop   ;
  80. : save-buffers   (s -- )
  81.    1 buffer#   #buffers 0
  82.    do   dup @ 1+   if  ?write-block  then
  83.        /bufhdr +
  84.    loop   drop   ;
  85.  
  86. \ Some debugging tools
  87. \ : .bh ( buffer-header -- )
  88. \    dup >block#      ." Block# "     @ .
  89. \    dup >file#       ."   File# "    @ .
  90. \    dup >bufadd      ."   Address "  @ .
  91. \        >bufflags    ."   Flags "    @ .
  92. \ ;
  93. \ : .bhs (s -- )  #buffers 1+ 0  do  i buffer# .bh  cr  loop  ;
  94. \ 
  95. \ : .read  ( bufadd file block -- )  ." Read "  . . . cr ;
  96. \ : .write ( bufadd file block -- )  ." Write " . . . cr ;
  97. \ ' .read  is read-block
  98. \ ' .write is write-block
  99.  
  100. empty-buffers
  101. needs file-io blockio.fth
  102. file-io
  103. needs load blockld.fth
  104.